Chip 2002 March/Chip_2002-03_cd1.bin/zkuste/delphi/kompon/d3456/EHS.ZIP/setup.exe/{app}/ehshelprouter.pas

Pascal/Delphi Source File | 2001-03-25 | 13.7 KB | 451 lines

{ THelpRouter

  Delphi 3/4/5/6 Implementation of HTML HELP

  ⌐ 2000-2001 EC Software. All rights reserved.

  This product and it's source code is protected by patents, copyright laws and
  international copyright treaties, as well as other intellectual property
  laws and treaties. The product is licensed, not sold.

  The source code and sample programs in this package or parts hereof
  as well as the documentation shall not be copied, modified or redistributed
  without permission, explicit or implied, of the author.


  EMail: [e-mail]
  Internet: http://www.ec-software.com

  Disclaimer of Warranty
  ----------------------

  THIS SOFTWARE AND THE ACCOMPANYING FILES ARE PROVIDED "AS IS" AND
  WITHOUT WARRANTIES OF ANY KIND WHETHER EXPRESSED OR IMPLIED.

  In no event shall the author be held liable for any damages whatsoever,
  including without limitation, damages for loss of business profits,
  business interruption, loss of business information, or any other loss
  arising from the use or inability to use the software. }

unit ehshelprouter;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus;

type
  THelpType = (htWinhelp, htHTMLhelp, htMixedMode);
  TShowType = (stDefault, stMain, stPopup);

  THtmlOption  = (hoSupportPopups, hoMixedMode);
  THtmlOptions = set of THtmlOption;

  THelpRouter = class(TComponent)
  private
    fHelpType: THelpType;
    fShowType: TShowType;
    fAppOnHelp: THelpEvent;
    fOnHelp: THelpEvent;
    fHelpfile: string;
    fCHMPopupTopics: string;
    fValidateID: boolean;
    fPP: TPoint;
    function  CurrentForm: TForm;
    function  OnRouteHelp(Command: Word; Data: Longint; var CallHelp: Boolean): Boolean;
    function  FindHandle(var returnHelpFile: string): HWND;
    procedure SetHelpType(value: THelpType);
    function  ValidateHTMLID(link: string): string;
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    function    HTMLhelpInstalled: boolean;
    function    HelpContent: boolean;
    function    HelpKeyword(keyword: string): boolean;
    function    HelpKLink(keyword: string): boolean;
    function    HelpALink(keyword: string): boolean;
    function    HelpJump(hfile, topicid: string): boolean;
    function    HelpPopup(X,Y: integer; HelpContext: integer; text: string): boolean;
  published
    property HelpType: THelpType read fHelpType write SetHelpType;
    property ShowType: TShowType read fShowType write fShowType default stDefault;
    property Helpfile: string read fHelpfile write fHelpfile;
    property CHMPopupTopics: string read fCHMPopupTopics write fCHMPopupTopics;
    property OnHelp: THelpEvent read fOnHelp write fOnHelp;
    property ValidateID: boolean read fValidateID write fValidateID;
  end;

var
   GLOBAL_HELPROUTER: THelpRouter;

implementation

uses ehshhapi;

var
   aHH_AKLINK: THH_AKLINK;
   aHH_POPUP: THH_POPUP;
   aHelpHandle: HWND;
   aKeyWord, aHelpFile: string;

function CheckRouterInstance: boolean;
begin
  result := false;
  if GLOBAL_HELPROUTER <> NIL then raise Exception.Create('Multiple instances of THelpRouter are not allowed')
  else result := true;
end;

{ --- THelpRouter --- }

constructor THelpRouter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if CheckRouterInstance and not (csDesigning in Componentstate) then
  begin
       fAppOnHelp := Application.onhelp;
       Application.onhelp := OnRouteHelp;
       GLOBAL_HELPROUTER := Self;
  end;
  fShowType := stDefault;
  fCHMPopupTopics := 'CSHelp.txt';
end;

destructor THelpRouter.Destroy;
begin
  if not (csDesigning in Componentstate) then
  begin
       if (Application.Handle <> 0) and (Application.HelpFile = '') then Application.HelpCommand(HELP_QUIT, 0);
       if assigned(fAppOnHelp) then Application.onhelp := fAppOnHelp else Application.onhelp := nil;
  end;
  GLOBAL_HELPROUTER := nil;
  inherited Destroy;
end;

function THelpRouter.CurrentForm: TForm;
begin
  if Screen.ActiveForm <> nil
    then result:= Screen.ActiveForm
    else result:= Owner as TForm;
end;

procedure THelpRouter.SetHelpType(value: THelpType);
begin
     if value <> fHelpType then
     begin
          fHelpType := value;
          if (fHelpType in [htHTMLhelp,htMixedMode])
            and (not (csDesigning in ComponentState)) then HTMLHelpInstalled;
     end;
end;

function THelpRouter.HTMLhelpInstalled: boolean;
begin
  if HHCTRL = 0 then LoadHH;
  result := assigned(HtmlHelpA);
end;

function THelpRouter.FindHandle(var returnHelpFile: string): HWND;
var
  CForm: TCustomForm;
begin
   returnHelpFile := Application.helpfile;
   result := Application.handle;
   CForm := CurrentForm;
   if Assigned(CForm) and CForm.HandleAllocated and (CForm.HelpFile <> '') then
   begin
       result := CForm.Handle;
       returnHelpFile := CForm.HelpFile;
   end;
   if fHelpFile <> '' then
   begin
       returnHelpFile := fhelpfile;
       result := Application.handle;
   end;
end;

function THelpRouter.OnRouteHelp(Command: Word; Data: Longint; var CallHelp: Boolean): Boolean;
const
   HELP_TAB = 15;
var
   showHTML: boolean;
   rHandle: integer;
begin
   result := false;
   if assigned(fOnHelp) then result := fOnHelp(command, data, callhelp);
   if not callHelp then exit;
   if assigned(fAppOnHelp) then result := fAppOnHelp(command, data, callhelp);
   if not callHelp then exit;

   if fShowType = stMain then
     case Command of
     HELP_SETPOPUP_POS: Command := 0;
     HELP_CONTEXTPOPUP: Command := HELP_CONTEXT; //no popup
     end;

   aHelpHandle := findHandle(aHelpfile);

   showHTML := false;
   case HelpType of
   htHTMLHelp:  showHTML := true;
   htMixedMode: showHTML := (command <> HELP_CONTEXTPOPUP) and
                            (command <> HELP_SETPOPUP_POS);
   end;

   if showHTML then
   begin
     if not HTMLhelpInstalled then exit; //result false

     rHandle := 0;
     aHelpFile := changefileext(aHelpFile,'.chm');
     case Command of
     HELP_TAB:
       case data of
       0: rHandle := HtmlHelpA(aHelpHandle, pchar(aHelpFile), HH_DISPLAY_TOC, 0);  //show table of contents
       else rHandle := HtmlHelpA(aHelpHandle, pchar(aHelpFile), HH_DISPLAY_INDEX, 0);  //display keyword
       end;
     HELP_FINDER,
     HELP_CONTENTS:
       rHandle := HtmlHelpA(aHelpHandle, pchar(aHelpFile), HH_DISPLAY_TOC, 0);  //show table of contents
     HELP_PARTIALKEY,
     HELP_KEY:
       rHandle := HtmlHelpA(aHelpHandle, pchar(aHelpFile), HH_DISPLAY_INDEX, data);  //display keyword
     HELP_QUIT:
       rHandle := HtmlHelpA(aHelpHandle, nil, HH_CLOSE_ALL, 0);
     HELP_SETPOPUP_POS:
       fPP := SmallPointToPoint(TSmallPoint(Data));
     HELP_CONTEXT:
       rHandle := HtmlHelpA(aHelpHandle, pchar(aHelpFile), HH_HELP_CONTEXT, data);  //display help context
     HELP_CONTEXTPOPUP:
       begin
            if (fPP.x = 0) and (fPP.y = 0) then GetCursorPos(fPP);
            HelpPopup(fPP.x, fPP.y, data, '');
            fPP := point(0,0); //reset;
            CallHelp := false;
            result := true;
            exit;
       end;
     end;
     Result := rHandle <> 0;
   end else
   begin
     if Command <> 0 then Result := WinHelp(aHelpHandle, PChar(changefileext(aHelpFile,'.hlp')), Command, Data)
     else Result := true;
   end;
   CallHelp := false;
end;

function THelpRouter.HelpContent: boolean;
begin
   result := application.helpcommand(15, 0);
end;

function THelpRouter.ValidateHTMLID(link: string): string;
var
   vli: integer;
begin
      result := '';
      for vli := 1 to length(link) do case link[vli] of
      '\',
      '/',
      '"',
      '|',
      ',',
      '?',
      '┐',
      ':': result := result + '';  //nothing
      ' ',
      '.',
      '%': result := result + '_';
      '>',
      '<': result := result + '~';
      '&',
      '*': result := result + '+';
      '[': result := result + '(';
      ']': result := result + ')';
      'Σ',
      '─': result := result + 'a';
      '÷',
      '╓': result := result + 'o';
      'ⁿ',
      '▄': result := result + 'u';
      '▀': result := result + 's';
      else result := result + link[vli];
      end;
end;


function THelpRouter.HelpJump(hfile, topicid: string): boolean;
var
   Command: array[0..255] of Char;
   rHandle: integer;
   HID: string;
begin
   result := false;
   aHelpHandle := FindHandle(aHelpFile);

   if Hfile <> '' then
   begin
        aHelpFile := HFile;
        aHelpHandle := 0;
   end;

   if HelpType in [htHTMLhelp,htMixedMode] then
   begin
     if not HTMLhelpInstalled then exit; //result false

     aHelpFile := changefileext(aHelpFile,'.chm');
     rHandle := 0;
     HID := TopicID;
     if HID <> '' then
     begin
          if copy(lowercase(extractfileext(HID)),1,4) <> '.htm' then
          begin
               if fValidateID then HID := ValidateHTMLID(HID);
               HID := HID + '.htm';
          end;
     end;
     if HID <> '' then
     begin
          aHelpFile := aHelpFile + '::/' + HID;
          rHandle := HtmlHelpA(aHelpHandle, pchar(aHelpFile), HH_DISPLAY_TOPIC, 0); //show topic
     end
     else rHandle := HtmlHelpA(aHelpHandle, pchar(aHelpFile), HH_HELP_FINDER, 0);  //show table of contents
     Result := rHandle <> 0;
   end
   else begin
     aHelpfile := changefileext(aHelpFile,'.hlp');
     StrLFmt(Command, SizeOf(Command) - 1, 'JumpID("","%s")', [TopicID]);
     Result := WinHelp(aHelpHandle, PChar(aHelpfile), HELP_CONTENTS, 0);
     if Result then Result := WinHelp(aHelpHandle, PChar(aHelpfile), HELP_COMMAND, Longint(@Command));
   end;
end;

function THelpRouter.HelpPopup(X,Y: integer; HelpContext: integer; Text: string): boolean;
var
   CForm: TForm;
begin
   if HTMLhelpInstalled then
   begin
     CForm := CurrentForm;
     with aHH_POPUP do
     begin
          cbStruct := sizeof(aHH_POPUP);
          hInst := 0;
          if Text = '' then idString := HelpContext
                       else idString := 0;
          pszText := PChar(text);
          pt.x := X;
          pt.y := Y;
          clrForeground := -1;
          clrBackground := -1;
          rcMargins.Left := -1;
          rcMargins.Right := -1;
          rcMargins.Top := -1;
          rcMargins.Bottom := -1;
          pszFont := PChar('MS Sans Serif, 8');
     end;

     if aHH_POPUP.idString <> 0 then
     begin
          if fCHMPopupTopics = '' then fCHMPopupTopics := 'CSHelp.txt';
          aHelpHandle := FindHandle(aHelpFile);
          aHelpFile := changefileext(aHelpFile,'.chm') + '::/'+fCHMPopupTopics;
          result := HtmlHelpA(aHelpHandle, pchar(aHelpFile), HH_DISPLAY_TEXT_POPUP, longint(@aHH_POPUP)) <> 0;
     end
     else result := HtmlHelpA(CForm.handle, nil, HH_DISPLAY_TEXT_POPUP, longint(@aHH_POPUP)) <> 0;
   end
   else result := false;
end;

function THelpRouter.HelpKeyword(keyword: string): boolean;
var
  Command: array[0..255] of Char;
begin
  StrLcopy(Command, pchar(keyword), SizeOf(Command) - 1);
  result := application.helpcommand(HELP_KEY, Longint(@Command));
end;

function THelpRouter.HelpKLink(keyword: string): boolean;
var
   Command: array[0..255] of Char;
   rHandle: integer;
   afile: string;
begin
   result := false;
   aHelpHandle := FindHandle(afile);

   if HelpType in [htHTMLhelp,htMixedMode] then
   begin
     if not HTMLhelpInstalled then exit; //result false

     rHandle := 0;
     aHelpFile := changefileext(afile,'.chm');
     aKeyWord := keyword+#0;

     with aHH_AKLINK do
     begin
          cbStruct := sizeof(aHH_AKLINK);
          fReserved := false;
          pszKeywords := pchar(aKeyword);
          pszUrl := '';
          pszMsgText := '';
          pszMsgTitle := '';
          pszMsgWindow := '';
          fIndexOnFail := true;
     end;
     rHandle := HtmlHelpA(aHelpHandle, pchar(aHelpfile), HH_DISPLAY_TOPIC, 0);  //create window
     if rHandle <> 0 then rHandle := HtmlHelpA(aHelphandle, pchar(aHelpfile), HH_KEYWORD_LOOKUP, longint(@aHH_AKLINK));
     Result := rHandle <> 0;
   end
   else begin
     aFile := changefileext(afile,'.hlp');
     StrLFmt(Command, SizeOf(Command) - 1, 'KL("%s",1)', [keyword]);
     Result := WinHelp(aHelpHandle, PChar(afile), HELP_CONTENTS, 0);
     if Result then Result := WinHelp(aHelpHandle, PChar(afile), HELP_COMMAND, Longint(@Command));
   end;
end;

function THelpRouter.HelpALink(keyword: string): boolean;
var
   Command: array[0..255] of Char;
   rHandle: integer;
   afile: string;
begin
   result := false;
   aHelpHandle := FindHandle(afile);

   if HelpType in [htHTMLhelp,htMixedMode] then
   begin
     if not HTMLhelpInstalled then exit; //result false

     rHandle := 0;
     aHelpFile := changefileext(afile,'.chm');
     aKeyWord := keyword+#0;

     with aHH_AKLINK do
     begin
          cbStruct := sizeof(aHH_AKLINK);
          fReserved := false;
          pszKeywords := pchar(akeyword);
          pszUrl := '';
          pszMsgText := '';
          pszMsgTitle := '';
          pszMsgWindow := '';
          fIndexOnFail := true;
     end;
     rHandle := HtmlHelpA(aHelpHandle, pchar(aHelpfile), HH_DISPLAY_TOPIC, 0);  //create window
     if rHandle <> 0 then rHandle := HtmlHelpA(aHelphandle, pchar(aHelpfile), HH_ALINK_LOOKUP, longint(@aHH_AKLINK));
     Result := rHandle <> 0;
   end
   else begin
     afile := changefileext(afile,'.hlp');
     StrLFmt(Command, SizeOf(Command) - 1, 'AL("%s",1)', [keyword]);
     Result := WinHelp(aHelpHandle, PChar(afile), HELP_CONTENTS, 0);
     if Result then Result := WinHelp(aHelpHandle, PChar(afile), HELP_COMMAND, Longint(@Command));
   end;
end;

end.